perm filename PLTSRT.F4[1,MUS] blob sn#079058 filedate 1973-12-21 generic text, type T, neo UTF8
00010	C  SUBRS. ALPHA, RHORZ, SLUR, JUGGLE, LOOP, PLTSRT, LINES, RDRAW
00020	
00100	C****** FOR LISTS OF LETTERS, ETC. *******
00200		SUBROUTINE ALPHA
00300		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00600		EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3))
00700		1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
00800		1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
00900		COMMON/STF/RSTFAC(8),RSTJC
01000	
01100		IF(JA.EQ.20)GO TO 20
01200	CC	RSTJC=RSTFAC(JC+4)
01300		JA=5
01400	54	R=19.7*RJE*RSTJC
01500		J=R
01600		RND=R-J
01700		R=0
01800		DO 50 KA=4,6
01900		JY=RJQ(KA)*100.+.2
02000		JX=1000000
02100		DO 53 LA=1,4
02200		JF=JY/JX
02300	CC	IF(JF.LT.90)CALL NOTWRT
02350		IF(JF.NE.47.AND.JF.LT.90)CALL NOTWRT
02400	C  47=BLANK  (WAS 99)
02500		JY=JY-JF*JX
02600		JB=JB+J
02700		R=R+RND
02800		IF(R.LT.1.0)GO TO 53
02900		JB=JB+1
03000		R=R-1.0
03100	53	JX=JX/100
03200	50	CONTINUE
03240		RETURN
03400	C  FOR TRILLS
03500	20	R=RJB
03600	C  R SAVES RJB(WHICH GETS CLOBBERED WHEN 'TR' IS WRITTEN.)
03750	C 20, POS1, STF, NT#, 0, POS2, X     IF X=1 THEN NO WAVEY LINE
03800		RJE=.65
03850		JE=0
03900		JA=5
04000		JF=29
04100	C   DRAWS T
04200		CALL NOTWRT
04300		JF=27
04400	C   DRAWS R
04500		JB=JB+11*RSTJC
04600	51	CALL NOTWRT
04750		IF(JG.NE.0)RETURN
04800		JB=JB+16*RSTJC
05000	C   RETURN IF NO WAVY LINE IS NEEDED
05100		JA=4
05200		RJB=R+4.*RSTJC
05300		JG=-2
05400	C  JG IS SWITCH TO DRAW WIGGLE
05500		RJE=RJD+.8
05600		CALL ITMSUB
05800		END
05900	
06000		FUNCTION RHORZ(R)
06100		RHORZ=R*5.96-596.
06200		END
06300	
06400	
06500		SUBROUTINE SLUR
06600		IMPLICIT INTEGER(A-Q,T-Z)
06700		REAL CENTR,PWDS
06710		COMMON /XRN/RN(4000) /PLTR/PLT,RHT,DIS
06900		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
07000		COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(8),RSTJC
07200		EQUIVALENCE (RJG,RJQ(5)),(RJF,RJQ(4)),(JG,JQ(5)),
07300		1(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
07400		1,(JF,JQ(4)),(RJD,RJQ(2)),(RJE,RJQ(3)),(RF,RJQ(20))
07500		DIMENSION SLURX(53),SLURY(53),RSEQ(26)
07600	      DATA RSEQ/70.0,64.0,59.0,53.9,49.0,44.1,40.0,35.8,32.0,28.2,
07700		1 25.0,21.8,19.0,16.3,14.0,11.9,10.0,8.4,6.8,5.3
07800		1 ,4.0,2.9,2.0,1.4,1.0,.07/
07805		IF(JA.NE.12)GO TO 2
07810		RA=5.96*RSTJC*RJE
07815		L=3
07820		IF(JG.LE.JF)JG=JG+360
07822		JH=6
07823		IF(PLT)JH=1
07825		DO 3 K=JF,JG,JH
07830		R=K
07835		CALL LINES(RJB+RA*SIND(R),CENTR+RA*COSD(R),L)
07840	3	L=2
07845	C  JA=12  DRAWS CIRCLES.  P5=RADIUS, P6=DEGR.1, P7=DEGR.2
07850		RETURN
07900	2	JJ=1
07902		KQ=1
07903		TWICE=0
07905		IF(PLT)GO TO 21
07910		TWICE=-1
07912		KQ=3
07930	21	RST7=RSTJC*7.
08000		IF(RJF.GT.1000)CALL RNOTE(RJF)
08010		GO TO (5,6,7),JH+4
08015		GO TO 4
08020	5	R=32
08025	C AFTER DOTTED NOTE
08030		GO TO 8
08040	6	R=22
08045	C BETWEEN NOTES
08050	8	RX=-1.3
08060		GO TO 9
08070	7	R=7
08080		RX=RSTJC
08090	9	RJB=RJB+R*RSTJC
08100		RJF=RJF+RX
08250	4	RXX=RHORZ(RJF)-RJB
08260		RTILT=(RJE-RJD)*RST7
08270	80	RX=SQRT(RXX**2+RTILT**2)
08280	1	R=CENTR
08300		IF(JH.GT.0)GO TO 180
08400	C  FOR BRACKETS
08410		RB=RX/52.
08500		DO 81 K=1,53
08600	81	SLURX(K)=RB*(K-1)+RJB
08700		RA=-RJG*RST7
08800		R=R-RA
08900		RW=630.
09010		RB=RA/RW
09100		DO 82 K=1,26
09200		SLURY(K)=RW*RB+R
09300		SLURY(54-K)=SLURY(K)
09400	82	RW=RW-RSEQ(K)
09500		SLURY(27)=SLURY(26)
09600		L=53
09700	
09800	89	IF(RTILT.EQ.0)GO TO 87
09900	CC	R=RTILT*RF
10000		RW=ATAN2(RTILT,RXX)
10100		RA=SIN(RW)
10200		RB=COS(RW)
10300		RZ=SLURX(1)
10400		RW=SLURY(1)
10500		DO 84 K=1,L
10600		SLURX(K)=SLURX(K)-RZ
10700	84	SLURY(K)=SLURY(K)-RW
10800		DO 83 K=1,L
10900		R=SLURX(K)
11000		SLURX(K)=RB*R-RA*SLURY(K)+RZ
11100	83	SLURY(K)=RB*SLURY(K)+RA*R+RW
11200	
11300	87	CALL LINES(SLURX(JJ),SLURY(JJ),3)
11400		DO 88 K=JJ+1,L,KQ
11500	88	CALL LINES(SLURX(K),SLURY(K),2)
11510		IF(TWICE)RETURN
11520		TWICE=-1
11530		RJG=RJG+.1
11540		GO TO 1
11600		RETURN
11700	180	RW=R+RJG*RST7
11750		KQ=1
11800		RX=RX+RJB
11900		RA=(RJE-RJD)*RST7
12000		SLURX(1)=RJB
12100		SLURY(1)=R
12200		SLURX(2)=RJB
12300		SLURY(2)=RW
12400		SLURX(3)=RX
12500		SLURY(3)=RW+RA
12600		SLURX(4)=RX
12700		SLURY(4)=R+RA
12800		L=4
12900		IF(JH.EQ.2)L=3
13000		IF(JH.EQ.3)JJ=2
13010		TWICE=-1
13100		GO TO 87
13200		END
13300	C  8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
13400	C        FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
13500	
13600	
13700	C********  JUGGLER  ********
13800		SUBROUTINE JUGGLE
13900		IMPLICIT INTEGER(A-Z)
14000		REAL DIS,RJB,PWDS,DISX,RN,RJC,RJB,RJQ,RJJ,RJF,RHT,A,B
14100		COMMON /DL/X22,SAVER,NAME /XRN/RN(4000)
14300	      COMMON/PTR/PWDS(250),ITEM,L,I,IX/DPY/ST(4000),WDS(250),MEDIT,IGO
14600	
14700		ITEM=ITEM-1
14800		JX=RN(MEDIT)+3
14900	C  WD CNT OF OLD ITEM
15000	C  I-IX IS WD CNT OF NEW ITEM
15100		JY=IX
15200		Z=I-IX-JX
15300	C  SPACE CHANGE
15400		IF(Z)2751,172,751
15500	751	CALL LOOP(I-1,MEDIT+JX,-1,Z,0,RN)
15600		JY=IX+Z
15700		GO TO 172
15800	
15900	2751	CALL LOOP(MEDIT+JX+Z,IX+Z-1,1,0,-Z,RN)
16000	
16100	172	J=RN(JY)+2
16200		CALL LOOP(0,J,1,MEDIT,JY,RN)
16300		I=IX+Z
16400	
16500	1751	X=ITEM+1
16600		JX=WDS(X22+1)-WDS(X22)
16700		J=WDS(X+1)-WDS(X)
16800		Y=J-JX
16900		JX=WDS(X)+Y+1
17000		IF(Y)2851,182,282
17100	282	CALL LOOP(WDS(X+1)+2,WDS(X22),-1,Y,0,ST)
17200		GO TO 182
17300	
17400	2851	CALL LOOP(WDS(X22+1)+Y+1,WDS(X)+Y+1,1,0,-Y,ST)
17500		JX=WDS(X)+1
17600	
17700	182	CALL LOOP(1,J,1,WDS(X22)+1,JX,ST)
17800		DO 183 K=X22+1,X
17900		PWDS(K)=PWDS(K)+Z
18000	183	WDS(K)=WDS(K)+Y
18100		ST(2)=WDS(X)
18200		X22=0
18400		END
18500	
18600	
18700		SUBROUTINE LOOP(I,J,K,L,M,N)
18800		DIMENSION N(1)
18900		DO 1 NN=I,J,K
19000	1	N(NN+L)=N(NN+M)
19200		END
19300	
19400	
19500		SUBROUTINE PLTSRT
19600	C  SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING. 
19700		IMPLICIT INTEGER(S-Z)
19800		COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
19940		COMMON/DPY/P(4000),WDS(250),MEDIT,IGO
20000		DO 4 K=1,ITEM
20100		L=PWDS(K)
20150		A=RN(L+2)
20200		P(K)=A+1000*RN(L+3)
20250	4	IF(A.LT.0)P(K)=-10000
20275	C  PLOTS ALL NEG. HORIZ. POSITIONS FIRST
20300		Y=I
20500	2	A=P(1)
20600		L=1
20700		DO 1 K=1,ITEM
20800		IF(A.LE.P(K))GO TO 1
20900		A=P(K)
21000		L=K
21100	1	CONTINUE
21200		IF(A.EQ.10000.)RETURN
21300	C  ALL ITEMS HAVE NOW BEEN SHUFFLED
21400		V=PWDS(L)
21500		P(L)=10000
21600		L=RN(V)+2
21700		CALL LOOP(0,L,1,Y,V,RN)
21800		Y=Y+L+1
21900		GO TO 2
22000		END
22100	
22200	
22300	
22400		SUBROUTINE BOX(I,R,STFF)
22500		COMMON /SIZ/RSZ,JCEN,KCEN /XRN/RN(4000) /STF/RSTFAC(8),RSTJC
22800		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
22900		DIMENSION N(100),STFF(1)
22950		EQUIVALENCE (N,RN(2901))
23000		IF(I)GO TO 4
23100		K=R+4
23200		K=(STFF(K)+AMOD(RN(I+4),100.0)*7.*RSTFAC(K)
23300		1 -60.0)*RSZ-KCEN
23400	C  AMOD IS FOR MINI NOTES AND CLEFS
23500		L=RHORZ(RN(I+2))*RSZ-JCEN-25
23600		IF(IABS(L).GT.550)L=512
23700		IF(IABS(K).GT.550)K=512
23800	1	CALL ALINE(L,K,L+50,K)
23900		CALL RVECT(0,100)
24000		CALL RVECT(-50,0)
24100		CALL RVECT(0,-100)
24200		L=L+25
24300	2	CALL ALINE(L,K-25,L,K+125)
24450	3	CALL DPYOUT(1)
24500		RETURN
24600	4	IF(I.LT.-1)GO TO 5
24700		CALL DPYSET(3,N,100)
24800		CALL DPYBRT(3)
24900	5	L=RHORZ(R)*RSZ-JCEN
25000		IF(IABS(L).GT.550)GO TO 6
25050	C DOESN'T TRY TO DRAW LINE OFF SCREEN
25100		CALL SETPOG(3)
25200		CALL ALINE(L,-511,L,511)
25300		CALL DPYOUT(3)
25400	6	CALL SETPOG(1)
25600		END
25700	
25800		SUBROUTINE LINES(A,B,L)
25900		COMMON /SIZ/RSZ,JCEN,KCEN /FL/IC,NZ,NX,RZ,XGP
26000		COMMON/DL/IXRX,SAVER,AA /PLTR/IPLT,RHT,DIS
26100		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
26200		COMMON/DPY/JJ(4000),WDS(250),MEDIT,IGO
26400		EQUIVALENCE (ITOP,JJ(3999)),(IBOT,JJ(4000)),(RXGP,WDS(250))
26402		1,(JJ2,JJ(2))
26500		DATA BB/260.0/,CC/3.5/,DD/1.43/,MX/512/,XGP/1200.0/
26600	C  SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
26700	22	GO TO 23
26800	C  CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
26900	24	AA=CC-DD*ABS(A)/BB
27000	C  USE THIS IN DDT TO DISTORT ITEMS.  CC MUST BE > DD
27100		B=B*AA
27200	23	IF(IPLT)GO TO 2
27300		M=A*RSZ
27400		N=B*RSZ
27500		IF(RSZ.LE.0.8571)GO TO 3
27600	C NEXT FOR DISPLAY MAGNIFICATION
27700		M=M-JCEN
27800		N=N-KCEN
27900		IF(JA.NE.10)GO TO 5
28000	C NEXT INSURES DISPLAY OF STAFF LINES
28100		IF(M.GT.511)M=511
28200		IF(M.LT.-511)M=-511
28400	5	IF(IABS(M).LT.512.AND.IABS(N).LT.512)GO TO 4
28500	C  NOW DRAWS INVISIBLE VECT. IF IT GOES OFF THE SCREEN.
28600		KZ=-1
28700		RETURN
28800	4	IF(KZ.EQ.0)GO TO 6
28900		KZ=0
29000		GO TO 1
29050	3	IF(JA.EQ.44)GO TO 6
29075	C JA=44=BAR LINES - THEY DON'T FIGURE IN MAX. HGT.
29100		K=B
29200		IF(K.GT.ITOP)ITOP=B
29300		IF(K.LT.IBOT)IBOT=B
29302	6	IF(JJ2.GT.3990)RETURN
29400		IF(L.EQ.3)GO TO 1
29500		CALL AVECT(M,N)
29600		RETURN
29700	1	CALL AIVECT(M,N)
29800		RETURN
29900	2	IF(IPLT.EQ.-2)RETURN
30000	CC	AX=.5
30100	CC	IF(A)AX=-AX
30200	CC	BX=.5
30300	C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
30400	CC	IF(B)BX=-BX
30500	C  AX AND BX ARE FOR ROUND-OFF
30600		IF(IXRX.EQ.0)GO TO 9
30610		M=ROFF(RXGP-B*RHT)
30620		N=ROFF(XGP+A*DIS)
30700	CC	M=-B*RHT-BX+RXGP
30800	CC	N=A*DIS+XGP+AX
30900		GO TO 8
31000	CC9	M=A*DIS+AX
31100	CC	N=B*RHT+BX
31110	9	M=ROFF(A*DIS)
31120		N=ROFF(B*RHT)
31200	8	CALL PLOT(M,N,L)
31400		END
31540	
31600		SUBROUTINE RDRAW(I,S,XY,X,RJB,CENTR,RMINI)
31700	C   TO X,Y INTO ONE WORD
31800		DIMENSION XY(1)
31900		DO 2 K=I,IFIX(S)
32000		L=2
32100		Y=XY(K)
32200		IF(Y.LT.1000.)GO TO 3
32300		L=3
32400		Y=Y-1000.
32500	C   >1000 = INVIS. LINE
32600	3	M=Y
32700		Y=(Y-M)*1000.
32800		IF(Y.GT.100.)Y=100-Y
32900	C   Y NUMBERS .GT.100 ARE NEG.
33000		B=Y*X+CENTR
33100		IF(M.GT.60)M=100-M
33200		A=M*RMINI+RJB
33300	2	CALL LINES(A,B,L)
33500		END